home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / textManip.tcl < prev    next >
Encoding:
Text File  |  1999-05-03  |  30.7 KB  |  1,120 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [string length [set text [getSelect]]]]} {
  6.     set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.     set text [getSelect]
  8.     } else {
  9.     set chars [maxPos]
  10.     set lines [lindex [posToRowCol $chars] 0]
  11.     set text [getText [minPos] [maxPos]]
  12.     }
  13.     regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
  14.     set words [llength $text]
  15.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  16. }
  17.  
  18.  
  19. # FILE: sortLines.tcl
  20. #
  21. # last update: 05/03/1999 {18:43:51 PM}
  22. #
  23. # This version of sortLines has the option of ignoring blanks/whitespace (-b)
  24. # and case-insensitive sorting (-i), or reverse sorting, and removing duplicates
  25. # if desired [-d]
  26. #     sortLines [-b] [-i] [-r] [-d]
  27.  
  28. # COPYRIGHT:
  29. #
  30. #    Copyright © 1992,1993 by David C. Black All rights reserved.
  31. #    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
  32. #   Portions copyright (c) 1999 Vince Darley, no rights reserved.
  33. #
  34. #    Redistribution and use in source and binary forms are permitted
  35. #    provided that the above copyright notice and this paragraph are
  36. #    duplicated in all such forms and that any documentation,
  37. #    advertising materials, and other materials related to such
  38. #    distribution and use acknowledge that the software was developed
  39. #    by David C. Black.
  40. #
  41. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  42. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  43. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  44. #
  45. ################################################################################
  46.  
  47. # AUTHOR
  48. #
  49. #    David C. Black
  50. #    GEnie:    D.C.Black
  51. #    Internet: black@mpd.tandem.com (preferred)
  52. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  53. #
  54. ################################################################################
  55.  
  56. proc reverseSort {} {sortLines -r}
  57.  
  58. proc sortLines {args} {
  59.     getOpts
  60.     
  61.     if {[info exists opts(-r)]} {
  62.     set mode "-decreas"
  63.     } else {
  64.     set mode "-increas"
  65.     }
  66.     
  67.     set start [getPos]
  68.     set end  [selEnd]
  69.     if {[pos::compare $start == $end]} {
  70.     alertnote "You must highlight the section you wish to sort."
  71.     return
  72.     }
  73.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  74.     alertnote "The selection must consist only of complete lines."
  75.     return
  76.     }
  77.     set text [split [getText $start [pos::math $end - 1]] "\r"]
  78.     if {[info exists opts(-b)] || [info exists opts(-i)] || [info exists opts(-d)]} {
  79.     foreach line $text {
  80.         if {[info exists opts(-i)]} {
  81.         set key [string tolower $line]
  82.         } else {
  83.         set key $line
  84.         }
  85.         if {[info exists opts(-b)]} {
  86.         regsub -all "\[ \t\]+" $key " " key
  87.         }
  88.         if {[info exists opts(-d)]} {
  89.         if {![info exists orig($key)]} {
  90.             set orig($key) $line
  91.             lappend list $key
  92.         }
  93.         } else {
  94.         while {[info exists orig($key)]} {
  95.             append key "z"
  96.         }
  97.         set orig($key) $line
  98.         lappend list $key
  99.         }
  100.     }
  101.     unset text
  102.     foreach key [lsort $mode $list] {
  103.         lappend text $orig($key)
  104.     }
  105.     } else {
  106.     set text [lsort $mode $text]
  107.     }
  108.     set text [join $text "\r"]
  109.     replaceText $start [pos::math $end - 1] $text
  110.     select $start [pos::math $start + [string length $text] +1]
  111. }
  112. # Test case:
  113. #
  114. # a  black
  115. # A  black dog
  116. # a black cat
  117. # A  Black dog
  118. # A  black dog
  119.  
  120.  
  121. ## 
  122.  # -------------------------------------------------------------------------
  123.  # 
  124.  # "sortParagraphs" --
  125.  # 
  126.  #  Sorts selected paragraphs according to their first 30 characters,
  127.  #  it's case insensitive and removes all non alpha-numeric characters
  128.  #  before the sort.
  129.  # -------------------------------------------------------------------------
  130.  ##
  131. proc sortParagraphs {args} {
  132.     set start [getPos]
  133.     set end  [selEnd]
  134.     if {[pos::compare $start == $end]} {
  135.     alertnote "You must highlight the section you wish to sort."
  136.     return
  137.     }
  138.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  139.     alertnote "The selection must consist only of complete lines."
  140.     return
  141.     }
  142.     set text [getText $start $end]
  143.     if {[string first "•" $text] != -1} {
  144.     alertnote "Sorry, can't sort paragraphs with bullets '•'."
  145.     return
  146.     }
  147.     regsub -all "\[\r\n\]\[ \t\]*\[\r\n]" $text "\r•" text
  148.     set paras [split $text "•"]
  149.     unset text
  150.     # now each paragraph ends in \r
  151.     foreach para $paras {
  152.     set key [string tolower [string range $para 0 30]]
  153.     regsub -all {[^-a-z0-9]} $key "" key
  154.     # so we don't clobber duplicates!
  155.     while {[info exists orig($key)]} {append key "z"}
  156.     set orig($key) $para
  157.     }
  158.     unset para
  159.     foreach key [lsort [array names orig]] {
  160.     lappend text $orig($key)
  161.     }
  162.     replaceText $start $end [join $text "\r"]
  163.     select $start $end
  164. }
  165.  
  166.  
  167.  
  168. #================================================================================
  169. # Block shift left and right.
  170. #================================================================================
  171.  
  172. proc shiftBy {amount} {
  173.     set start [lineStart [getPos]]
  174.     set end [nextLineStart [pos::math [selEnd] - 1]]
  175.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  176.     set text [text::indentBy [getText $start $end] $amount]
  177.     replaceText $start $end $text
  178.     set end [pos::math $start + [string length $text]]
  179.     if {[pos::compare [nextLineStart $start] == $end]} {
  180.     goto [pos::math $start + [string length $text] - [string length [string trimleft $text]]]
  181.     } else {
  182.     select $start $end
  183.     }
  184. }
  185.  
  186. proc shiftRight {} {
  187.     global indentationAmount
  188.     shiftBy $indentationAmount
  189. }
  190.  
  191. proc shiftLeft {} {
  192.     global indentationAmount
  193.     shiftBy -$indentationAmount
  194. }
  195.  
  196. proc shiftLeftSpace {} {
  197.     shiftBy -1
  198. }
  199.  
  200. proc shiftRightSpace {} {
  201.     shiftBy 1
  202. }
  203.  
  204. proc doShiftLeft {shiftChar} {
  205.     set start [lineStart [getPos]]
  206.     set end [nextLineStart [pos::math [selEnd] - 1]]
  207.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  208.     
  209.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  210.     
  211.     set textout ""
  212.     
  213.     foreach line $text {
  214.     if {[regexp "($shiftChar)(.*)$" $line "" "" c]} {
  215.         lappend textout $c
  216.     } else {
  217.         lappend textout $line
  218.     }
  219.     }
  220.     
  221.     set text [join $textout "\r"]    
  222.     replaceText $start [pos::math $end - 1] $text
  223.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  224. }
  225.  
  226. proc doShiftRight {shiftChar} {
  227.     set start [lineStart [getPos]]
  228.     set end [nextLineStart [pos::math [selEnd] - 1]]
  229.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  230.     
  231.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  232.     
  233.     set text "$shiftChar[join $text \r${shiftChar}]"
  234.     replaceText $start [pos::math $end - 1] $text
  235.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  236. }
  237.  
  238. proc selectAll {} {
  239.     select [minPos] [maxPos]
  240. }
  241.  
  242. # Select the next or current word. If word already selected, will go to next.
  243. proc hiliteWord {} {
  244.     if {[pos::compare [getPos] != [selEnd]]} forwardChar
  245.     forwardWord
  246.     set start [getPos]
  247.     backwardWord
  248.     select $start [getPos] 
  249. }
  250.  
  251. ## 
  252.  # -------------------------------------------------------------------------
  253.  # 
  254.  # "togglePrefix" --
  255.  # 
  256.  #  Useful for e.g. Tcl mode to add/remove a '$', TeX to add/remove 
  257.  #  a backslash, etc.  Only works for single character prefixes.
  258.  # -------------------------------------------------------------------------
  259.  ##
  260. proc togglePrefix {pref} {
  261.     set p [getPos]
  262.     backwardWord
  263.     if {[lookAt [getPos]] == $pref} {
  264.     deleteChar
  265.     goto [pos::math $p -1]
  266.     } else {
  267.     insertText $pref
  268.     goto [pos::math $p +1]
  269.     }
  270. }
  271.  
  272. proc twiddle {} {
  273.     set pos [getPos]
  274.     if {[pos::compare $pos == [minPos]]} return
  275.     if {[pos::compare $pos == [maxPos]] || \
  276.       [pos::compare $pos == [pos::math [nextLineStart $pos] - 1]]} {
  277.     set incr -1
  278.     } else {
  279.     set incr 0
  280.     }
  281.     if {[string length [set text [getSelect]]]} {
  282.     if {[string length $text] == 1} {
  283.         return
  284.     } else {
  285.         set sel [pos::math [selEnd] + $incr]
  286.         set one [lookAt [pos::math $sel -1]]
  287.         set two [lookAt $pos]
  288.         replaceText $pos $sel "$one[getText [pos::math $pos + 1] [pos::math $sel - 1]]$two"
  289.         select $pos $sel
  290.         return
  291.     }
  292.     }
  293.     set pos [pos::math $pos + $incr]
  294.     set one [lookAt $pos]
  295.     set two [lookAt [pos::math $pos - 1]]
  296.     replaceText [pos::math $pos - 1] [pos::math $pos + 1] "$one$two"
  297.     select [pos::math $pos - 1] [pos::math $pos + 1]
  298. }
  299.  
  300. proc twiddleWords {} {
  301.     global wordBreakPreface wordBreak
  302.     set pos [getPos]
  303.     if {[pos::compare $pos == [maxPos]] || $pos == [pos::math [nextLineStart $pos] - 1]} {
  304.     set eol 1
  305.     } else {
  306.     set eol 0
  307.     }
  308.     if {[pos::compare [getPos] != [selEnd]]} {
  309.     set start1 [getPos]; set end2 [selEnd]
  310.     select $start1
  311.     forwardWord; set end1 [getPos]
  312.     goto $end2
  313.     backwardWord; set start2 [getPos]
  314.     } else {
  315.     if {$eol} {
  316.         backwardWord; set pos [getPos]
  317.     }
  318.     select $pos
  319.     backwardWord; set start1 [getPos]
  320.     forwardWord; set end1 [getPos]
  321.     goto $pos
  322.     forwardWord; set end2 [getPos]
  323.     backwardWord; set start2 [getPos]
  324.     }        
  325.     
  326.     if {$start1 != $start2} {
  327.     set mid [getText $end1 $start2]
  328.     replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  329.     select $start1 $end2
  330.     }
  331. }
  332.  
  333. # proc commentLine {} {insertPrefix}
  334. proc commentLine {} {
  335.     global mode
  336.     global ${mode}::commentCharacters
  337.     if {![catch {commentCharacters Paragraph} chars]} {
  338.     set start [lindex $chars 0]
  339.     set end [lindex $chars 1]
  340.     if {[string trim $start] == [string trim $end]} {
  341.         insertPrefix
  342.     } else {
  343.         set ext  [file extension [win::CurrentTail]]
  344.         if {($mode == "C" || $mode == "C++") && $ext != ".h" && $ext != ".c"} {
  345.         insertPrefix
  346.         } else {
  347.         beginningOfLine
  348.         insertText $start
  349.         endOfLine
  350.         insertText $end
  351.         beginningOfLine
  352.         }
  353.     }
  354.     } else {
  355.     insertPrefix
  356.     }
  357. }
  358.  
  359. proc uncommentLine {} {removePrefix}
  360. proc insertPrefix {} {doPrefix insert}
  361. proc removePrefix {} {doPrefix remove}
  362. proc doPrefix {which} {
  363.     global prefixString
  364.     if {[pos::compare [set start [getPos]] == [set end [selEnd]]]} {
  365.     set end [nextLineStart $start]
  366.     }
  367.     set start [lineStart $start]
  368.     set text [getText $start $end]
  369.     replaceText $start $end [doPrefixText $which $prefixString $text]
  370.     goto $start
  371.     endOfLine
  372. }
  373.  
  374. proc quoteChar {} {
  375.     message "Literal keystroke to be inserted:"
  376.     insertText [getChar]
  377. }
  378.  
  379. proc setPrefix {} {
  380.     global prefixString
  381.     if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
  382.     set prefixString $res
  383. }
  384.  
  385. proc setSuffix {} {
  386.     global suffixString
  387.     if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
  388.     set suffixString $res
  389. }
  390.  
  391. proc insertSuffix {} {doSuffix insert}
  392. proc removeSuffix {} {doSuffix remove}
  393. proc doSuffix {which} {
  394.     global suffixString
  395.     set pts [getEndpts]
  396.     set start [lindex $pts 0]
  397.     set end [lindex $pts 1]
  398.     set start [lineStart $start]
  399.     set end [nextLineStart [pos::math $end - 1]]
  400.     set text [getText $start $end]
  401.     set text [doSuffixText $which $suffixString $text]
  402.     replaceText $start $end $text
  403.     select $start [getPos]
  404. }
  405.  
  406. proc commentBox {} {
  407.  
  408.     # Preliminaries
  409.     if {[commentGetRegion Box]} { return }
  410.     
  411.     set commentList [commentCharacters Box]
  412.     if {![llength $commentList]} { return }
  413.     
  414.     set begComment [lindex $commentList 0]
  415.     set begComLen [lindex $commentList 1]
  416.     set endComment [lindex $commentList 2]
  417.     set endComLen [lindex $commentList 3]
  418.     set fillChar [lindex $commentList 4]
  419.     set spaceOffset [lindex $commentList 5]
  420.  
  421.     set aSpace " "
  422.  
  423.     # First make sure we grab a full block of lines and adjust highlight
  424.  
  425.     set start [getPos]
  426.     set start [lineStart $start]
  427.     set end [selEnd]
  428.     set end [nextLineStart [pos::math $end - 1]]
  429.     select $start $end
  430.  
  431.     # Now get rid of any tabs
  432.     
  433.     if {[pos::compare $end < [maxPos]]} {
  434.     createTMark stopComment [pos::math $end + 1]
  435.     tabsToSpaces
  436.     gotoTMark stopComment
  437.     set end [pos::math [getPos] - 1]
  438.     removeTMark stopComment
  439.     } else {
  440.     tabsToSpaces
  441.     set end [maxPos]
  442.     }
  443.     select $start $end
  444.     set text [getText $start $end]
  445.     
  446. # Next turn it into a list of lines--possibly drop an empty 'last line'
  447.  
  448.     set lineList [split $text "\r\n"]
  449.     set numLines [llength $lineList]
  450.     if {[lindex $lineList end] == {} } {
  451.     set lineList [lrange $lineList 0 [expr {$numLines -2}]]
  452.     set numLines [llength $lineList]
  453.     }
  454.  
  455. # Find the longest line length and determine the new line length
  456.  
  457.     set maxLength 0
  458.     foreach thisLine $lineList {
  459.     set thisLength [string length $thisLine]
  460.     if { $thisLength > $maxLength } { 
  461.         set maxLength $thisLength 
  462.     }
  463.     }
  464.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  465.     
  466.     # Now create the top & bottom bars and a blank line
  467.  
  468.     set topBar $begComment
  469.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  470.     append topBar $fillChar
  471.     }
  472.     set botBar ""
  473.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  474.     append botBar $fillChar
  475.     }
  476.     append botBar $endComment
  477.     set blankLine $fillChar
  478.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  479.     append blankLine " "
  480.     }
  481.     append blankLine $fillChar
  482.     
  483.     # For each line add stuff on left and spaces and stuff on right for box sides
  484.     # and concatenate everything into 'text'.  Start with topBar; end with botBar
  485.  
  486.     set text $topBar\r$blankLine\r
  487.     
  488.     set frontStuff $fillChar
  489.     set backStuff $fillChar
  490.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  491.     append frontStuff " "
  492.     set backStuff $aSpace$backStuff
  493.     }
  494.     set backStuffLen [string length $backStuff]
  495.     
  496.     foreach thisLine $lineList {
  497.     set thisLine $frontStuff$thisLine
  498.     set thisLength [string length $thisLine]
  499.     set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  500.     for { set j 0 } { $j < $howMuchPad } { incr j } {
  501.         append thisLine " "
  502.     }
  503.     append thisLine $backStuff
  504.     append text $thisLine \r
  505.     }
  506.     
  507.     append text $blankLine \r $botBar \r
  508.     
  509. # Now replace the old stuff, turn spaces to tabs, and highlight
  510.  
  511.     replaceText    $start $end $text
  512.     set    end [pos::math $start + [string length $text]]
  513.     frontSpacesToTabs $start $end
  514. }
  515.  
  516. proc uncommentBox {} {
  517.  
  518. # Preliminaries
  519.     if {[commentGetRegion Box 1]} { return }
  520.     
  521.     set commentList [commentCharacters Box]
  522.     if {![llength $commentList]} { return }
  523.     
  524.     set    begComment [lindex $commentList    0]
  525.     set    begComLen [lindex $commentList 1]
  526.     set    endComment [lindex $commentList    2]
  527.     set    endComLen [lindex $commentList 3]
  528.     set    fillChar [lindex $commentList 4]
  529.     set    spaceOffset [lindex $commentList 5]
  530.     
  531.     set aSpace " "
  532.     set aTab \t
  533.  
  534.     # First make sure we grab a full block of lines
  535.  
  536.     set start [getPos]
  537.     set start [lineStart $start]
  538.     set end [selEnd]
  539.     set end [nextLineStart [pos::math $end - 1]]
  540.     set text [getText $start $end]
  541.  
  542.     # Make sure we're at the start and end of the box
  543.  
  544.     set startOK [string first $begComment $text]
  545.     set endOK [string last $endComment $text]
  546.     set textLength [string length $text]
  547.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } {
  548.     alertnote "You must highlight the entire comment box, including the borders."
  549.     return
  550.     }
  551.     
  552.     # Now get rid of any tabs
  553.     
  554.     if {[pos::compare $end < [maxPos]] } {
  555.     createTMark stopComment [pos::math $end + 1]
  556.     tabsToSpaces
  557.     gotoTMark stopComment
  558.     set end [pos::math [getPos] - 1]
  559.     removeTMark stopComment
  560.     } else {
  561.     tabsToSpaces
  562.     set end [maxPos]
  563.     }
  564.     select $start $end
  565.     set text [getText $start $end]
  566.     
  567. # Next turn it into a list of lines--possibly drop an empty 'last line'
  568.  
  569. # VMD May'95: changed this code segment because it
  570. # previously had problems with empty lines in the
  571. # middle of the text to be commented
  572.  
  573.     set lineList [split $text "\n\r"]
  574.     set ll [llength $lineList]
  575.     if { [lindex $lineList end] == {} } {
  576.     set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  577.     }
  578.     set numLines [llength $lineList]
  579.  
  580. # end changes.
  581.     
  582. # Delete the first and last lines, recompute number of lines
  583.  
  584.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  585.     set lineList [lreplace $lineList 0 0 ]
  586.     set numLines [llength $lineList]
  587.     
  588.     # Eliminate 2nd and 2nd-to-last lines if they are empty
  589.  
  590.     set eliminate $fillChar$aSpace$aTab
  591.     set thisLine [lindex $lineList [expr {$numLines-1}]]
  592.     set thisLine [string trim $thisLine $eliminate]
  593.     if { [string length $thisLine] == 0 } {
  594.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  595.     }
  596.     set thisLine [lindex $lineList 0]
  597.     set thisLine [string trim $thisLine $eliminate]
  598.     if { [string length $thisLine] == 0 } {
  599.     set lineList [lreplace $lineList 0 0 ]
  600.     }
  601.     set numLines [llength $lineList]    
  602.     
  603. # For each line trim stuff on left and spaces and stuff on right and splice
  604.  
  605.     set dropFromLeft [expr {$spaceOffset+1}]
  606.     set text ""
  607.     foreach thisLine $lineList {
  608.     set thisLine [string trimright $thisLine $eliminate]
  609.     set thisLine [string range $thisLine $dropFromLeft end]
  610.     append text $thisLine \r
  611.     }
  612.         
  613.     # Now replace the old stuff, convert spaces back to tabs
  614.  
  615.     replaceText    $start $end $text
  616.     set end [pos::math $start + [string    length $text]]
  617.     frontSpacesToTabs $start $end
  618. }
  619.  
  620. ## 
  621.  # -------------------------------------------------------------------------
  622.  #     
  623.  # "commentCharacters" --
  624.  #    
  625.  #    Adds the 'general' purpose characters which
  626.  #    are    used to    check if we're in a    comment    block.
  627.  #    Also has a check for an array entry like this:
  628.  #    
  629.  #    set C++::commentCharacters(General) [list "*" "//"]
  630.  #    
  631.  #    If such an entry exists, it is returned.  This allows mode authors
  632.  #    to keep everything self-contained.
  633.  # -------------------------------------------------------------------------
  634.  ##
  635. proc commentCharacters {purpose} {
  636.     global mode commentCharacters
  637.     global ${mode}::commentCharacters
  638.     # allows a mode to define these things itself.
  639.     if {[info exists ${mode}::commentCharacters(${purpose})]} {
  640.     return [set ${mode}::commentCharacters(${purpose})]
  641.     }    
  642.     if {[info exists commentCharacters(${mode}:${purpose})]} {
  643.     return $commentCharacters(${mode}:${purpose})
  644.     }    
  645.     switch -- $purpose {
  646.     "General" {
  647.         switch -- $mode {
  648.         "TeX" {return "%" }
  649.         "Text" {return "!" }
  650.         "Fort" {return "C" }
  651.         "Scil" {return "//" }
  652.         "Perl" -
  653.         "Tcl" {return "\#" }
  654.         "C" {return "*" }
  655.         "Java" -
  656.         "C++" {return [list "*" "//"] }
  657.         "HTML" {return "<!--"}
  658.         default {
  659.             return
  660.         }
  661.         }
  662.     }        
  663.     "Paragraph" {        
  664.         switch -- $mode {
  665.         "TeX" {return [list "%% " " %%" " % "] }
  666.         "Text" {return [list "!! " " !!" " ! "] }
  667.         "Fort" {return [list "CC " " CC" " C "] }
  668.         "Scil" {return [list "//" "//" "//"] }
  669.         "Perl" -
  670.         "Tcl" {return [list "## " " ##" " # "] }
  671.         "Java" -
  672.         "C" -
  673.         "C++" {return [list "/* " " */" " * "] }
  674.         "HTML" { return [list "<!--" "-->" "|" ] }
  675.         default {
  676.             message "I don't know what comments should look like in this mode.  Sorry."
  677.             error "No comment characters"
  678.         }
  679.         }
  680.     }
  681.     "Box" {
  682.         switch -- $mode {
  683.         "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  684.         "Text" {return [list "!" 1 "!" 1 "!" 3] }
  685.         "Fort" {return [list "C" 1 "C" 1 "C" 3] }
  686.         "Scil" {return [list "//" 2 "//"  2 "//" 3] }
  687.         "Perl" -
  688.         "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  689.         "Java" -
  690.         "C" -
  691.         "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  692.         "HTML" { return [list "<!--" 4 "-->" 3 "|" 3] }
  693.         default {
  694.             message "I don't know what comments should look like in this mode.  Sorry."
  695.             error "No comment characters"
  696.         }
  697.         }    
  698.     }
  699.     }    
  700.     
  701. }
  702.  
  703. ## 
  704.  # Default is to look for a    paragraph to comment out.
  705.  # If sent '1',    then we    look for a commented region    to 
  706.  # uncomment.
  707.  ##
  708. proc commentGetRegion { purpose {uncomment 0 } } {
  709.     if {[pos::compare [getPos] != [selEnd]]} {
  710.     watchCursor
  711.     return 0
  712.     }
  713.     
  714.     # there's no selection, so we try and generate one
  715.     
  716.     set pos [getPos]
  717.     if {$uncomment} {
  718.     # uncommenting
  719.     set commentList [commentCharacters $purpose]
  720.     if { [llength $commentList] == 0 } { return 1}
  721.     switch -- $purpose {
  722.         "Box" {
  723.         set begComment [lindex $commentList 0]
  724.         set begComLen [lindex $commentList 1]
  725.         set endComment [lindex $commentList 2]
  726.         set endComLen [lindex $commentList 3]
  727.         set fillChar [lindex $commentList 4]
  728.         set spaceOffset [lindex $commentList 5]
  729.         
  730.         # get length of current line
  731.         set line [getText [lineStart $pos] [nextLineStart $pos] ]
  732.         set c [string trimleft $line]
  733.         set slen [expr {[string length $line] - [string length $c]}]
  734.         set start [string range $line 0 [expr {$slen -1 }] ]
  735.                 
  736.         set pos [getPos]
  737.                 
  738.         if { $start == "" } {
  739.             set p $pos
  740.             while { [string first $fillChar $line] == 0 && \
  741.               [expr {[string last $fillChar $line] + [string length $fillChar]}] \
  742.               >= [string length [string trimright $line]] } {
  743.             set p [nextLineStart $p]
  744.             set line [getText [lineStart $p] [nextLineStart $p]]
  745.             }
  746.             set end [lineStart $p]
  747.             
  748.             set p $pos
  749.             set line "${fillChar}"
  750.             while { [string first $fillChar $line] == 0 && \
  751.               [expr {[string last $fillChar $line] + [string length $fillChar]}] \
  752.               >= [string length [string trimright $line]] } {
  753.             set p [prevLineStart $p]
  754.             set line [getText [prevLineStart $p] [lineStart $p] ]
  755.             }
  756.             set begin [prevLineStart $p]
  757.             
  758.         } else {
  759.             set line "$start"
  760.             set p $pos
  761.             while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
  762.             set p [nextLineStart $p]
  763.             set line [getText [lineStart $p] [nextLineStart $p]]
  764.             }
  765.             set end [prevLineStart $p]
  766.             
  767.             set p $pos
  768.             set line "$start"
  769.             while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
  770.             set p [prevLineStart $p]
  771.             set line [getText [prevLineStart $p] [lineStart $p] ]
  772.             }
  773.             set begin [lineStart $p]
  774.         }
  775.         
  776.         set beginline [getText $begin [nextLineStart  $begin]]
  777.         if { [string first "$begComment" "$beginline" ] != $slen } {
  778.             message "First line failed"
  779.             return 1
  780.         }
  781.         
  782.         set endline [getText $end [nextLineStart $end]]
  783.         set epos [string last "$endComment" "$endline"]
  784.         incr epos [string length $endComment]
  785.         set s [string range $endline $epos end ]
  786.         set s [string trimright $s]
  787.         
  788.         if { $s != "" } {
  789.             message "Last line failed"
  790.             return 1
  791.         }
  792.         
  793.         set end [nextLineStart $end]
  794.         select $begin $end
  795.         #alertnote "Sorry auto-box selection not yet implemented"
  796.         }
  797.         "Paragraph" {
  798.         set begComment [lindex $commentList 0]
  799.         set endComment [lindex $commentList 1]
  800.         set fillChar [lindex $commentList 2]
  801.                 
  802.         ## 
  803.          # basic idea is search    back and forwards for lines
  804.          # that    don't begin    the    same way and then see if they
  805.          # match the idea of the beginning and end of a    block
  806.          ##
  807.         
  808.         set line [getText [lineStart $pos] [nextLineStart $pos] ]
  809.         set chk [string range $line 0 [string first $fillChar $line]]
  810.         if { [string trimleft $chk] != "" } {
  811.             message "Not in a comment block"
  812.             return 1
  813.         }
  814.         regsub -all {    } $line " " line
  815.         set p [string first "$fillChar" "$line"]
  816.         set start [string range "$line" 0 [expr {$p + [string length $fillChar] -1}]]
  817.         set ll [commentGetFillLines $start]
  818.         set begin [lindex $ll 0]
  819.         set end [lindex $ll 1]
  820.         
  821.         set beginline [getText $begin [nextLineStart  $begin]]
  822.         if {[string first "$begComment" "$beginline" ] != $p } {
  823.             message "First line failed"
  824.             return 1
  825.         }
  826.                 
  827.         set endline [getText $end [nextLineStart $end]]
  828.         set epos [string last "$endComment" "$endline"]
  829.         incr epos [string length $endComment]
  830.         set s [string range $endline $epos end ]
  831.         set s [string trimright $s]
  832.         
  833.         if { $s != "" } {
  834.             message "Last line failed"
  835.             return 1
  836.         }
  837.         #goto $end
  838.         set end [nextLineStart $end]
  839.         select $begin $end
  840.         }
  841.     }
  842.     } else {
  843.     # commenting out
  844.     set searchString "^\[ \t\]*\$"
  845.     set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  846.     set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  847.     if {[llength $searchResult1]} {
  848.         set posStart [pos::math [lindex $searchResult1 1] + 1]
  849.     } else {
  850.         set posStart [minPos]
  851.     }
  852.     if {[llength $searchResult2]} {
  853.         set posEnd [lindex $searchResult2 0]
  854.     } else {
  855.         set posEnd [pos::math [maxPos] + 1]
  856.         goto [maxPos]
  857.         insertText "\n"
  858.     }
  859.     select $posStart $posEnd
  860.     }
  861.     
  862.     set str "Do you wish to "
  863.     if {$uncomment} { append str "uncomment" } else { append str "comment out" }
  864.     append str " this region?"
  865.     return [expr {![dialog::yesno $str]}]
  866. }
  867.  
  868.  
  869. proc prevLineStart { pos } {
  870.     return [lineStart [pos::math [lineStart $pos] - 1]]
  871. }
  872.  
  873. proc commentSameStart { line start } {
  874.     regsub -all "\t" $line " " line
  875.     if {[string first "$start" "$line"] == 0 } {
  876.     return 1
  877.     } else {
  878.     return 0
  879.     }
  880. }
  881.  
  882. proc commentGetFillLines { start } {
  883.     set pos [getPos]
  884.     regsub -all "\t" $start " " start
  885.     set line "$start"
  886.     
  887.     set p $pos
  888.     while { [commentSameStart "$line" "$start"] } {
  889.     set p [nextLineStart $p]
  890.     set line [getText [lineStart $p] [nextLineStart $p]]
  891.     }
  892.     set end [lineStart $p]
  893.     
  894.     set p $pos
  895.     set line "$start"
  896.     while { [commentSameStart "$line" "$start"] } {
  897.     set p [prevLineStart $p]
  898.     set line [getText [prevLineStart $p] [lineStart $p] ]
  899.     }
  900.     set begin [prevLineStart $p]
  901.     return [list $begin $end]
  902. }
  903.  
  904. ## 
  905.  # Author: Vince Darley    <mailto:darley@fas.harvard.edu> 
  906.  ##
  907.  
  908. proc commentParagraph {} {
  909.  
  910. # Preliminaries
  911.     if {[commentGetRegion Paragraph]} { return }
  912.     
  913.     set commentList [commentCharacters Paragraph]
  914.     if { [llength $commentList] == 0 } { return }
  915.  
  916.     set begComment [lindex $commentList 0]
  917.     set endComment [lindex $commentList 1]
  918.     set fillChar [lindex $commentList 2]
  919.     
  920.     
  921.     # First make sure we grab a full block of lines and adjust highlight
  922.     
  923.     set start [getPos]
  924.     set start [lineStart $start]
  925.     set end [selEnd]
  926.     set end [nextLineStart [pos::math $end - 1]]
  927.     select $start $end
  928.     
  929.     # Now get rid of any tabs
  930.     
  931.     if {[pos::compare $end < [maxPos]] } {
  932.         createTMark stopComment [pos::math $end + 1]
  933.         tabsToSpaces
  934.         gotoTMark stopComment
  935.         set end [pos::math [getPos] - 1]
  936.         removeTMark stopComment
  937.     } else {
  938.         tabsToSpaces
  939.         set end [maxPos]
  940.     }
  941.     select $start $end
  942.     set text [getText $start $end]
  943.     
  944. # Next turn it into a list of lines--possibly drop an empty 'last line'
  945.  
  946.     set lineList [split $text "\r\n"]
  947.     set ll [llength $lineList]
  948.     if { [lindex $lineList end] == {} } {
  949.         set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  950.     }
  951.     set numLines [llength $lineList]
  952.     
  953.     # Find left margin for these lines
  954.     set lmargin 100
  955.     foreach l $lineList {
  956.         set lm [expr {[string length $l] - [string length [string trimleft $l]]}]
  957.         if { $lm < $lmargin } { set lmargin $lm }
  958.     }
  959.     set ltext ""
  960.     for { set i 0 } { $i < $lmargin } { incr i } {
  961.         append ltext " "
  962.     }
  963.     
  964.     # For each line add stuff on left and concatenate everything into 'text'. 
  965.     
  966.     set text ${ltext}${begComment}\r
  967.     
  968.     foreach l $lineList {
  969.         append text ${ltext} ${fillChar} [string range $l $lmargin end] \r
  970.     }
  971.     append text ${ltext} ${endComment} \r
  972.     
  973.     # Now replace the old stuff, turn spaces to tabs, and highlight
  974.     
  975.     replaceText $start $end $text
  976.     set end [pos::math $start + [string length $text]]
  977.     frontSpacesToTabs $start $end
  978. }
  979.  
  980. ## 
  981.  # Author: Vince Darley    <darley@fas.harvard.edu>
  982.  ##
  983.  
  984. proc uncommentParagraph {} {
  985.  
  986.     # Preliminaries
  987.     if {[commentGetRegion Paragraph 1]} { return }
  988.     
  989.     set commentList [commentCharacters Paragraph]
  990.     if { [llength $commentList] == 0 } { return }
  991.     
  992.     set begComment [lindex $commentList 0]
  993.     set endComment [lindex $commentList 1]
  994.     set fillChar [lindex $commentList 2]
  995.     
  996.     set aSpace " "
  997.     set aTab \t
  998.     
  999.     # First make sure we grab a full block of lines and adjust highlight
  1000.     
  1001.     set start [getPos]
  1002.     set start [lineStart $start]
  1003.     set end [selEnd]
  1004.     set end [nextLineStart [pos::math $end - 1]]
  1005.     select $start $end
  1006.     set text [getText $start $end]
  1007.     
  1008.     # Find left margin for these lines
  1009.     set l [string range $text 0 [string first "\r" $text] ]
  1010.     set lmargin [expr {[string length $l] - [string length [string trimleft $l]]}]
  1011.     
  1012.     # Make sure we're at the start and end of the paragraph
  1013.  
  1014.     set startOK [string first $begComment $text]
  1015.     set endOK [string last $endComment $text]
  1016.     set textLength [string length $text]
  1017.     if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } {
  1018.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  1019.         return
  1020.     }
  1021.     
  1022.     # Now get rid of any tabs
  1023.     
  1024.     if {[pos::compare $end < [maxPos]]} {
  1025.         createTMark stopComment [pos::math $end + 1]
  1026.         tabsToSpaces
  1027.         gotoTMark stopComment
  1028.         set end [pos::math [getPos] - 1]
  1029.         removeTMark stopComment
  1030.     } else {
  1031.         tabsToSpaces
  1032.         set end [maxPos]
  1033.     }
  1034.     select $start $end
  1035.     set text [getText $start $end]
  1036.     
  1037.     # Next turn it into a list of lines--possibly drop an empty 'last line'
  1038.     
  1039.     set lineList [split $text "\r\n"]
  1040.     set ll [llength $lineList]
  1041.     if { [lindex $lineList end] == {} } {
  1042.         set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  1043.     }
  1044.     set numLines [llength $lineList]
  1045.     
  1046.     # Delete the first and last lines, recompute number of lines
  1047.     
  1048.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  1049.     set lineList [lreplace $lineList 0 0 ]
  1050.     set numLines [llength $lineList]
  1051.     
  1052.     # get the left margin
  1053.     set lmargin [string first $fillChar [lindex $lineList 0]]
  1054.     set ltext ""
  1055.     for { set i 0 } { $i < $lmargin } { incr i } {
  1056.         append ltext " "
  1057.     }
  1058.     
  1059.     # For each line trim stuff on left and spaces and stuff on right and splice
  1060.     set eliminate $fillChar$aSpace$aTab
  1061.     set dropFromLeft [expr {[string length $fillChar] + $lmargin}]
  1062.     set text ""
  1063.     foreach thisLine $lineList {
  1064.         set thisLine [string trimright $thisLine $eliminate]
  1065.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  1066.         append text $thisLine \r
  1067.     }
  1068.     
  1069.     # Now replace the old stuff, turn spaces to tabs, and highlight
  1070.     
  1071.     
  1072.     replaceText    $start $end $text
  1073.     set    end [pos::math $start + [string length $text]]
  1074.     frontSpacesToTabs $start $end
  1075. }
  1076.  
  1077.  
  1078. proc frontTabsToSpaces { start end } {
  1079.     select $start $end
  1080.     tabsToSpaces
  1081. }
  1082.  
  1083. proc frontSpacesToTabs { start end } {
  1084.     getWinInfo a
  1085.     set sp [string range "              " 1 $a(tabsize) ]
  1086.     set from [lindex [posToRowCol $start] 0]
  1087.     set to [lindex [posToRowCol $end] 0]
  1088.     while {$from <= $to} {
  1089.     set pos [rowColToPos $from 0]
  1090.     # get the leading whitespace of the current line
  1091.     set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
  1092.     if {![llength $res]} {
  1093.         # end of the file
  1094.         return
  1095.     }
  1096.     regsub -all "($sp| +\t)" [eval getText $res] "\t" front
  1097.     eval replaceText $res [list $front]
  1098.     incr from
  1099.     }
  1100. }
  1101.  
  1102. proc forwardDeleteUntil {{c ""}} {
  1103.     if {$c == ""} {
  1104.     message "Forward delete up to next:"
  1105.     set c [getChar]
  1106.     }
  1107.     set p [lindex [search -s -n -f 1 -r 1 [quote::Regfind $c] [getPos]] 0]
  1108.     if {$p != ""} {
  1109.     deleteText [getPos] [pos::math $p + 1]
  1110.     }
  1111. }
  1112.  
  1113. proc forwardDeleteWhitespace {} {
  1114.     set p [lindex [search -s -n -f 1 -r 1 "\[^ \t\r\n\]" [getPos]] 0]
  1115.     if {$p != ""} {
  1116.     deleteText [getPos] $p
  1117.     }
  1118. }
  1119.  
  1120.